perm filename TRNSP.F4[MSS,LCS]3 blob
sn#237510 filedate 1976-02-11 generic text, type T, neo UTF8
SUBROUTINE TRNSP(IT,TR)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) /STF/RFAC(1) /LLL/LEND
CC DIMENSION JSIG(14)
CC DATA JSIG/4,1,5,2,6,3,0,0,3,6,2,5,1,4/
KSIG=99
SIG=0
NSIG=-1
SLUR=0
PRX=99
MS=0
TTR=AMOD(TR,7.0)
K=1
DO 47 L=1,IT
J=KPN(L)
X=Q(J+1)
IF(X.EQ.17)GO TO 199
C FOUND KSIG, SO DON'T DO THE REST
IF(X.EQ.3)MS=L
C REMEMBER WHERE CLEF IS
47 IF(X.LT.3)GO TO 41
C LEAVE LOOP IF WE'VE GONE TOO FAR.
41 IF(TTR.EQ.0)GO TO 199
TYPE 42
42 FORMAT(' ADD KEY SIG? -- ',$)
43 FORMAT(A1)
ACCEPT 43,X
IF(X.NE.'Y')GO TO 199
C NEXT EXPANDS DATA. PUT THIS IN FAIL LATER
J=KPN(MS+1)
L=KPN(IT)+7
DO 45 N=L,J,-1
45 Q(N+7)=Q(N)
DO 46 N=IT+2,MS+1,-1
46 KPN(N+1)=KPN(N)+7
L=KPN(MS+1)
Q(L)=4
Q(L+1)=17
CC IT'S ALREADY 0 ***** Q(L+2)=0
Q(L+3)=7*RFAC(9)
Q(L+4)=0
Q(L+5)=0
C THIS WILL BE CHANGED LATER.
Q(L+6)=CLFNUM(Q,KPN,MS)
C GETS THE CLEF NUM.
CC KPN(MS+1)=KPN(MS)+6
IT=IT+1
LEND=IT+1
CALL EXPND(MS,0)
C 2ND ARG IS DUMMY -- LINE IS SHIFTED TO RT.
199 J=KPN(K)
X=Q(J+1)
IF(X.EQ.1)GO TO 1
IF(X.NE.3)GO TO 2
CLEF=Q(J+5)
IF(Q(J).LT.3)CLEF=0
IF(TR.NE.4)GO TO 21
C NEXT FOR HORN IN F CLEF CHANGES
IF(CLEF.GE.100)CLEF=CLEF-100
C HORN CLEF CHANGES ARE KEPT, BS. CL'S ARE THROWN AWAY
21 IF(TR.NE.8)GO TO 100
C NEXT FOR BASS CL. CLEF CHANGES.
IF(CLEF.NE.0)Q(J+5)=0
IF(CLEF.LT.100)GO TO 100
CC Q(J+1)=1089.
CALL SHRNK(K,IT)
C MAKE IT INVISIBLE IF IT WAS MINI.
CLEF=CLEF-100
GO TO 199
2 IF(X.NE.4)GO TO 20
BAR=-1
MS=1
GO TO 100
20 IF(X.NE.17)GO TO 12
C HOW ABOUT CHANGE TO NO SIG? OK, CODE =99
NSIG=0
2000 ADD=2
IF(TR.EQ.4)ADD=1
IF(TR.EQ.2)ADD=-3
C 4=F, 3=G, 2=A, -2=E FLAT
IF(TR.EQ.-2)ADD=3
IF(TR.EQ.3)ADD=-1
IF(TTR.EQ.0)ADD=0
R=0
IF(X.EQ.17)R=Q(J+5)
SIG=R
R=ADD+R
KSIG=R
C FOR LATER CHECKS
C TO USE IN IMPROVED ROUTINE
C******* ADD NO-YES SIG FEATURE *******
IF(X.EQ.1)GO TO 1000
Q(J+5)=R
IF(R.NE.0)GO TO 399
CALL SHRNK(K,IT)
K=K-1
CC IF(ADD.EQ.0)Q(J+1)=1089.
C CHANGE CODE TO 99 IF NO SIG.(1089.=11.*99.)
399 IF(CLEF.NE.1)GO TO 100
C ONLY FOR BASS CLEF KSIGS (FR. HORN, BASS CLAR)
R=CLEF
IF(TR.EQ.8)R=0
Q(J+6)=R
GO TO 100
12 IF(X.EQ.5)GO TO 120
IF(X.NE.6)GO TO 100
120 RT=TR
IF(RT.NE.8)GO TO 121
IF(CLEF.EQ.1)RT=-4
121 Q(J+4)=Q(J+4)+RT
Q(J+5)=Q(J+5)+RT
IF(X.EQ.5)SLUR=Q(J+6)
C SAVES RIGHT POS. OF SLUR
GO TO 100
C FOR BEAMS AND SLURS
1 IF(KSIG.EQ.99)GO TO 2000
1000 RT=TR
R=Q(J+4)
RX=AMOD(R,100.0)
RZ=AMOD(RX,7.0)
C THE NOTE NUM
R5=Q(J+5)
A=AMOD(R5,10.0)
C THE ACCI
RN(MS)=A
RN(MS+1)=RX
C SAVE FOR REPEATS
MS=MS+2
CHNAT=3
IF(MS.LT.4)GO TO 205
N=MS-3
200 IF(RX.NE.RN(N))GO TO 201
IF(A.EQ.0)GO TO 204
C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
IF(A.EQ.RN(N-1))GO TO 204
GO TO 203
204 IF(TR.NE.8)GO TO 4
IF(CLEF.EQ.1)RT=RT-12
C FOR BSCLAR
GO TO 4
201 N=N-2
IF(N.GT.0)GO TO 200
205 IF(NSIG)CHNAT=0
203 ADD=A
C THE CHANGE IN ACCI
IF(PRX.NE.RX)GO TO 44
C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
IF(A.NE.0)GO TO 44
C NOW SAME NOTE, NO ACCI
IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
C FOUND CONNECTING TIE
CC IF(BAR.EQ.0)GO TO 204
C THIS ↑↑↑↑ ALWAYS PUTS ACCI AFTER A BAR -- EVEN WITH TIE------
C OR SET MS BACK TO 1 WHEN TIE IS PRESENT. THIS WILL
CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
IF(BAR)MS=1
GO TO 204
44 IF(NSIG)GO TO 440
IF(A.EQ.0)GO TO 443
C ONLY CHECKS ON MOTES WITH NO ACCI
440 IF(TR.NE.1)GO TO 5
C NEXT FOR B-FLAT TRANSPOSITIONS
9 IF(RZ.EQ.0)GO TO 7
IF(RZ.NE.3)GO TO 4
C NOW FOUND A B OR E
7 IF(A.EQ.0)GO TO 70
IF(A.NE.3)GO TO 71
C CHNG NO ACCI OR NAT TO SHARP
70 ADD=2
71 IF(A.EQ.1)GO TO 30
C CHNG FLAT TO NAT.
IF(A.NE.2)GO TO 3
C NEXT FOR B#, E#
RT=RT+1
C MOVE IT UP A STEP
30 ADD=CHNAT
C MAKE IT NAT. IF NEEDED
3 Q(J+5)=R5-A+ADD
4 PRX=RX
40 Q(J+4)=R+RT
BAR=0
GO TO 100
443 IF(CLEF.NE.1)GO TO 4
5 IF(TR.NE.4)GO TO 6
C FOUND "F" TRANS.
IF(CLEF.EQ.1)GO TO 60
C MAKE ADJUSTMENT FOR BASS CLEF
8 IF(RZ.EQ.0)GO TO 7
GO TO 4
6 IF(TR.NE.8)GO TO 10
C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
IF(CLEF.NE.1)GO TO 61
60 RZ=RZ-5
IF(RZ)RZ=RZ+7
IF(TR.EQ.4)GO TO 8
RT=RT-12
61 IF(NSIG)GO TO 9
IF(A.NE.0)GO TO 9
GO TO 4
10 IF(TR.NE.2)GO TO 11
IF(RZ.EQ.1)GO TO 101
IF(RZ.EQ.4)GO TO 101
IF(RZ.NE.5)GO TO 4
C FOR "A". FINDS C,F AND G.
101 IF(A.EQ.0)GO TO 102
IF(A.NE.3)GO TO 103
C FINDS NO ACCI OR NAT.
102 ADD=1
103 IF(A.EQ.2)GO TO 30
GO TO 3
11 IF(TR.NE.3)GO TO 110
IF(RZ.NE.4)GO TO 4
ADD=1
C "G" F→Bb, F#→B NAT.
IF(A.EQ.2)GO TO 30
C NOTHING FOR bb OR ## YET
GO TO 3
110 IF(TR.NE.-2)GO TO 4
C IF NOT -2 IT IS NOW THOUGHT TO BE SOME OCTAVE SHIFT.
IF(RZ.EQ.3)GO TO 111
IF(RZ.EQ.0)GO TO 111
IF(RZ.NE.6)GO TO 4
111 IF(A.EQ.0)GO TO 112
IF(A.NE.3)GO TO 113
112 ADD=2
113 IF(A.EQ.1)GO TO 30
C FOR Eb TRNS
GO TO 3
100 IF(K.GE.IT)GO TO 299
K=K+1
GO TO 199
299 CALL RVRS(IT)
C TO REVERSE STEMS, BEAMS AND SLURS
END
SUBROUTINE RVRS(IT)
COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
K=1
1 J=KPN(K)
R=Q(J+1)
IF(R.NE.1)GO TO 2
C JUMP IF NOT A NOTE
IF(Q(J+5).LT.10)GO TO 10
C JUMP IF NO STEM ON IT
KK=K+1
3 IF(KK.GT.IT)RETURN
JJ=KPN(KK)
RR=Q(JJ+1)
IF(RR.NE.1)GO TO 5
C JUMP IF NOT A NOTE
IF(Q(JJ+5).GE.10)GO TO 6
C SKIP CHORD NOTES (NO STEM)
7 KK=KK+1
GO TO 3
C DID NOT FIND BEAM NEARBY
6 RZ=AMOD(Q(J+4),100.0)
N=J+5
A=10
IF(RZ.GE.7)GO TO 60
IF(Q(N).LT.20)GO TO 10
C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
A=-A
GO TO 15
60 IF(Q(N).GE.20)GO TO 10
C THERE MUST BE A BETTER WAY!
15 Q(N)=Q(N)+A
GO TO 10
8 IF(Q(N).LT.20)GO TO 10
A=-A
C STEM UP
GO TO 15
5 IF(RR.NE.6)GO TO 6
20 B=Q(JJ+4)
C=Q(JJ+5)
D=(B+C)/2.
IF(RR.EQ.5)GO TO 9
IF(RR.NE.6)GO TO 10
B=Q(JJ+6)+1.
C SAVES RANGE OF BEAM +1.
IF(Q(JJ+7).GE.20)GO TO 11
C NOW STEMS ARE UP
IF(D.LT.7)GO TO 12
C JUMP TO 12 IF ALL OK
CC C=-10
JSTM=0
C SAVE FOR REVERSED STEMS
GO TO 23
11 IF(D.GE.7.)GO TO 12
C STEMS DOWN
C JUMP IF NO REVERSE NEEDED
JSTM=-1
23 JH=0
CHNG=0
DO 16 N=K,IT
KK=KPN(N)
IF(Q(KK+3).GT.B)GO TO 140
R=Q(KK+1)
IF(R.NE.1)GO TO 17
L=5
R=Q(KK+8)
C THE STEM LENGTH
IF(R.EQ.999)R=0
Q(KK+8)=-R
C FOR THE INVERSION
19 C=10.
A=Q(KK+L)
IF(A.GE.20)C=-C
Q(KK+L)=C+A
IF(JH.NE.0)GO TO 161
C NEXT FOR 1ST NOTE UNDER BEAM
JH=4
160 R=Q(JJ+JH)-Q(KK+4)
C=-1
IF(JSTM)GO TO 163
C=R
R=1
C NOW STEMS UP
163 IF(R.GT.C)GO TO 162
C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
CHNG=C-R
IF(JSTM.EQ.0)CHNG=-CHNG
JH=JJ+4
Q(JH)=Q(JH)+CHNG
JH=JH+1
Q(JH)=Q(JH)+CHNG
162 IF(L)GO TO 141
C FOR ESCAPE FROM LOOP
161 JH=KK
C JH SAVES PTR TO LAST NOTE UNDER BEAM
GO TO 16
17 IF(R.NE.6)GO TO 18
C NOW IT'S A BEAM
L=7
GO TO 19
18 IF(R.NE.5)GO TO 16
C NOW IT'S A SLUR
C=-4
IF(Q(KK+7))C=-C
CALL SLRV(KK,C)
C TO REVERSE SLUR
CC Q(KK+7)=-Q(KK+7)
16 CONTINUE
C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
140 KK=JH
L=-1
JH=5
C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
GO TO 160
141 IF(CHNG.EQ.0)GO TO 14
IF(CHNG)CHNG=-CHNG
DO 142 N=K,IT
C TO READJUST STEMS UNDER REVERSED BEAMS
KK=KPN(N)
IF(Q(KK+3).GT.B)GO TO 14
IF(Q(KK+1).NE.1)GO TO 142
Q(KK+8)=Q(KK+8)+CHNG
C THE STEM LENGTH
142 CONTINUE
GO TO 14
C NEXT FOR SLURS
9 B=-4
IF(Q(JJ+7))GO TO 24
IF(D.GT.7)GO TO 10
C JUMP TO LEAVE STEM UP
GO TO 25
24 IF(D.LT.5)GO TO 10
C JUMP TO LEAVE STEM DOWN
B=-B
CC25 Q(JJ+4)=Q(JJ+4)+B
CC Q(JJ+5)=Q(JJ+5)+B
CC Q(JJ+7)=-R
25 CALL SLRV(JJ,B)
GO TO 10
12 DO 13 N=K+1,IT
KK=KPN(N)
13 IF(Q(KK+3).GT.B)GO TO 14
C JUMP OUT WHEN PAST END OF BEAM.
14 K=N-1
GO TO 10
2 IF(R.NE.6)GO TO 21
22 JJ=J
RR=R
GO TO 20
21 IF(R.EQ.5)GO TO 22
10 IF(K.GT.IT)RETURN
K=K+1
GO TO 1
END